MacTech 1 to 12

home *** CD-ROM | disk | FTP | other *** search

/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 09 - 1993 / 09.02 Feb 93 / Jörg's Folder / Development.4th < prev next >

Wrap

Text File | 1992-11-10 | 31.9 KB | 1,563 lines | [TEXT/NISI]

ONLY MAC DEFINITIONS ALSO FORTH ALSO ASSEMBLER GLOBAL VOCABULARY DEVELOPMENT ONLY ASSEMBLER ALSO MAC ALSO DEVELOPMENT DEFINITIONS ALSO FORTH GLOBAL CREATE MODULE.list ( points to the last module record in the MODULE list. ) MACH $41ED HERE 4- W! $-B86 HERE 2- W! \ VP @ HERE 2- W! 4 VP +! $2D084E75 , CODE ,IMMED ( set bit 9 - the immediate bit - of the trap word ) JSR HERE MOVE.L (A6)+,A0 ORI.W #$0200,-2(A0) RTS END-CODE IMMEDIATE -2 ALLOT : ,MARKS ( set bit 9 - for diacSens = FALSE ) ; IMMEDIATE -2 ALLOT : ,NEWOS ( set bit 9, clear bit 10 - for OS GetTrapAddress calls ) ; IMMEDIATE -2 ALLOT : ,CLEAR ( set bit 9 of the trap word ) ; IMMEDIATE CODE ,CASE ( set bit 10 - the case-sensitive bit - for _CmpString ) JSR HERE MOVE.L (A6)+,A0 ORI.W #$0400,-2(A0) RTS END-CODE IMMEDIATE -2 ALLOT : ,ASYNC ( set bit 10 - the asynchronous bit - for device driver calls ) ; IMMEDIATE -2 ALLOT : ,SYS ( set bit 10 to get a system heap operation ) ; IMMEDIATE -2 ALLOT : ,AUTO-POP ( set bit 10 to have the trap return pop the top return address) ; IMMEDIATE CODE ,NEWTOOL ( set bit 9 and 10 - for ToolBox GetTrapAddress calls ) JSR HERE MOVE.L (A6)+,A0 ORI.W #$0600,-2(A0) RTS END-CODE IMMEDIATE \ allocate the StripAddress mask GLOBAL CREATE StripAddress.mask MACH $41ED HERE 4- W! $-B6E HERE 2- W! $2D084E75 , \ allocate the SysEnvRec GLOBAL CREATE MACH2.SysEnvRec MACH $41ED HERE 4- W! $-B7E HERE 2- W! $2D084E75 , \ allocate the flags variable GLOBAL CREATE MACH2.flags MACH $41ED HERE 4- W! $-B82 HERE 2- W! $2D084E75 , \ bit 0 = Gestalt exists \ bit 1 = Apple Events exists \ bit 2 = SysEnvirons exists \ bit 3 = WaitNextEvent exists \ bit 4 = Used internally during System 7 COLD startup ONLY ASSEMBLER ALSO MAC ALSO FORTH DEFINITIONS \ create a variable for HERE GLOBAL CREATE (HERE) MACH $41ED HERE 4- W! $-1EC HERE 2- W! $2D084E75 , \ create a variable for High Level Event Handler chain GLOBAL CREATE HLE.handler MACH $41ED HERE 4- W! $-B8A HERE 2- W! $2D084E75 , 0 GLOBAL USER NEXT_TASK 4 GLOBAL USER S0 8 GLOBAL USER PS 12 GLOBAL USER RETURN_STK 40 GLOBAL USER HEAD 44 GLOBAL USER TAIL 48 GLOBAL USER CTR 52 GLOBAL USER PTR 56 GLOBAL USER ECHO 60 GLOBAL USER FILEID 62 GLOBAL USER V/WD.RefNum 64 GLOBAL USER CONTEXT 68 GLOBAL USER CURRENT 72 GLOBAL USER TaskWindowPointer 76 GLOBAL USER ABORT-ACTION 80 GLOBAL USER (ABORT) 84 GLOBAL USER (NUMBER) 88 GLOBAL USER (EXPECT) 92 GLOBAL USER (TYPE) 96 GLOBAL USER (?TERMINAL) 100 GLOBAL USER (QUERY) 104 GLOBAL USER PenLocation 108 GLOBAL USER TaskMenuBar 116 GLOBAL USER MenuData 124 GLOBAL USER ControlData 128 GLOBAL USER ControlHandle 136 GLOBAL USER DialogData 140 GLOBAL USER DialogHandle 144 GLOBAL USER UserVector 148 GLOBAL USER UserData 152 GLOBAL USER CONTENT-HOOK 156 GLOBAL USER DRAG-HOOK 160 GLOBAL USER GROW-HOOK 164 GLOBAL USER GOAWAY-HOOK 168 GLOBAL USER UPDATE-HOOK 172 GLOBAL USER ACTIVATE-HOOK 176 GLOBAL USER DEVICE_EXPECT 180 GLOBAL USER DEVICE_QTERM 184 GLOBAL USER DEVICE_TYPE 188 GLOBAL USER ATALK_SOCKET 190 GLOBAL USER DIALOG-HOOK 194 GLOBAL USER ZOOMIN-HOOK 198 GLOBAL USER ZOOMOUT-HOOK 202 GLOBAL USER C_Action 212 GLOBAL USER FileI/OID ONLY MAC DEFINITIONS ALSO FORTH ALSO ASSEMBLER GLOBAL CODE CmpString ( str1 str2 - flag ) ( compares two strings ) MOVEQ.L #0,D0 MOVE.L 4(A6),A0 MOVE.B (A0)+,D0 SWAP.W D0 MOVE.L (A6),A1 MOVE.B (A1)+,D0 EXG.L D4,A7 _CmpString EXG.L D4,A7 ( returns a result code in D0, zero if they match ) ADDQ.L #4,A6 SUBQ.L #1,D0 ( make result true if trap return is zero ) MOVE.L D0,(A6) RTS END-CODE ONLY MAC ALSO ASSEMBLER ALSO DEVELOPMENT DEFINITIONS ALSO FORTH HEADER str.#ifdef DC.B 6 DC.B '#ifdef' .ALIGN HEADER str.#ifndef DC.B 7 DC.B '#ifndef' .ALIGN HEADER str.#else DC.B 5 DC.B '#else' .ALIGN HEADER str.#endif DC.B 6 DC.B '#endif' .ALIGN : #endif ; IMMEDIATE GLOBAL : exec.word ( name.string -- ) FIND DROP LINK>BODY EXECUTE ; : (#ifdef) ( lfa found.flag -- ) { | word.addr exit.flag } IF ( -- LFA ) DROP ( get all the next words and bypass them until a #else, #ifdef, #ifndef, #endif, open-paren, or back-slash is encountered, then execute it ) 0 -> exit.flag BEGIN 32 WORD ( -- a ) -> word.addr word.addr C@ CASE 1 OF word.addr 1+ C@ DUP ASCII ( = SWAP ASCII \ = OR IF word.addr exec.word THEN ENDOF 5 OF ( test to see if the word is a "#else" ) word.addr 1+ C@ ASCII # = IF ( perform the string comparison ) word.addr ['] str.#else CmpString IF 1 -> exit.flag THEN THEN ENDOF 6 OF ( test to see if the word is a "#endif" or "#ifdef" ) word.addr 1+ C@ ASCII # = IF ( attempt the string comparison ) word.addr ['] str.#endif CmpString IF 1 -> exit.flag ELSE word.addr ['] str.#ifdef CmpString IF 1 -> exit.flag word.addr exec.word THEN THEN THEN ENDOF 7 OF ( test to see if the word is a "#ifndef" ) word.addr 1+ C@ ASCII # = IF ( attempt the string comparison ) word.addr ['] str.#ifndef CmpString IF 1 -> exit.flag word.addr exec.word THEN THEN ENDOF ENDCASE exit.flag UNTIL ELSE DROP ( the address ) ( continue interpreting the words following the #ifdef or #ifndef ) THEN ; : #ifdef 32 WORD FIND 0= ( -- lfa flag ) (#ifdef) ; IMMEDIATE : #ifndef 32 WORD FIND 0= NOT ( -- lfa flag ) (#ifdef) ; IMMEDIATE : #else ( if this word gets executed it's because an #ifdef or #ifndef was true, so the first part was compiled/executed. If #ifdef or #ifndef resolved to false, then this word is bypassed and all the following words up to the #endif are executed/compiled. ) { | word.addr repeat.flag } 32 WORD -> word.addr word.addr ['] str.#ifdef CmpString word.addr ['] str.#ifndef CmpString OR IF word.addr exec.word ELSE ( look for an #ifdef, #ifndef, #endif or comment char ) 1 -> repeat.flag BEGIN word.addr 1+ C@ ASCII # = IF word.addr ['] str.#ifdef CmpString word.addr ['] str.#ifndef CmpString OR IF 0 -> repeat.flag word.addr exec.word ELSE word.addr ['] str.#endif CmpString IF 0 -> repeat.flag THEN THEN ELSE word.addr C@ 1 = IF word.addr 1+ C@ DUP ASCII ( = SWAP ASCII \ = OR IF word.addr exec.word THEN THEN THEN repeat.flag WHILE 32 WORD -> word.addr REPEAT THEN ; IMMEDIATE : #define CREATE -4 ALLOT $4E75 W, ; IMMEDIATE ( These next set of words set up the saving of the CURRENT and CONTEXT states.) GLOBAL CODE push.VOCAB.state MOVE.L 64(A4),-(A6) MOVE.L 68(A4),-(A6) RTS END-CODE MACH GLOBAL CODE pop.VOCAB.state ( context current -- ) MOVE.L (A6)+,68(A4) MOVE.L (A6)+,64(A4) END-CODE MACH #define _RECORDS_ $1F CONSTANT count.mask ( masks out the name flags in the dict. header ) $40 CONSTANT MACH.bit ( used for getting the MACH bit setting ) GLOBAL CODE LINK>SEG MOVE.L (A6),A0 \ get the Link field address ADDQ.L #4,A0 \ point to the name string CLR.L D0 \ clear out D0 MOVE.B (A0),D0 \ get the length byte ANDI.B #$1F,D0 \ mask out the immed, mach, bits ADDQ.L #1,A0 \ point to the first byte of name ADD.L D0,A0 \ add the length ADDQ.L #1,A0 \ adjust for even address MOVE.L A0,D0 \ put in a data register ANDI.B #$FE,D0 MOVE.L D0,(A6) \ put sfa on stack RTS END-CODE GLOBAL CODE MCOMPILE ( addr -- ) ( macro compile from an address up to an RTS ) HERE \ get first free dictionary location MOVE.L (A6)+,A1 \ put it in A1 MOVE.L (A6)+,A0 \ get the passed-in PFA MOVE.W #$4E75,D1 \ an RTS for comparison CLR.L D2 \ counter for ALLOT @copycode MOVE.W (A0)+,D0 CMP.W D1,D0 BEQ.S @donecopy MOVE.W D0,(A1)+ ADDQ.W #2,D2 BRA.S @copycode @donecopy MOVE.L D2,-(A6) ALLOT RTS END-CODE GLOBAL : is.MACH? 4 + C@ MACH.bit AND 0= NOT ; ( lfa -- flag ) GLOBAL : is.name.field.word? link>seg W@ 1 = ; ( lfa -- flag ) : insert.offset ( n -- ) HERE 4 - W@ L_EXT + HERE 4 - W! ; GLOBAL : macro.compile { lfa -- } ( first test for name-field words ( HEADER and local vars ) ) lfa link>seg DUP W@ 1 = IF ( -- sfa ) 2+ DUP W@ ( get the first instruction ) CASE $2D3C ( MOVE.L #addr,-(A6) ) OF ( -- cfa ) DUP 2+ @ ( get the starting absolute address ) HERE - 2- ( get the PC offset from here to location ) ( now test for CodeRec or *CodeRec ) ( -- cfa offset ) SWAP 8 + @ $12344321 = IF ( it is a *CodeRec ) $207A W, W, \ MOVEA.L d(PC),A0 $41E8 W, \ LEA d(A0),A0 0 W, $2D08 W, \ MOVE.L A0,-(A6) ELSE ( it is a CodeRec ) $41FA W, W, ( LEA d(PC),A0 ) $2D08 W, ( MOVE.L A0,-(A6) ) THEN ENDOF $4EAD ( JSR d(A5) ) OF ( it is a local variable ) ( -- cfa ) 4 + W@ ( get the A2 offset ) $206A W, W, ( MOVEA.L d(A2),A0 ) $41E8 W, ( LEA d(A0),A0 ) 0 W, $2D08 W, ( MOVE.L A0,-(A6) ) ENDOF ENDCASE ELSE ( it is some sort of normal variable ) DROP ( the sfa ) ( first do a special handler for PC-relative macro variables ) lfa is.MACH? lfa LINK>BODY W@ DUP $41FA = ( is the first instruction an LEA d(PC),A0 ) SWAP $207A = OR AND ( is the first instruction an MOVEA d(PC),A0 ) IF HERE ( save the current HERE value ) lfa LINK>BODY 2+ DUP W@ + ( save the absolute address ) lfa LINK>BODY mcompile ( -- old.here addr ) SWAP 2+ DUP ( -- addr @ext.word @ext.word ) ROT SWAP - SWAP W! ELSE ( do a normal macro compile ) lfa LINK>BODY mcompile THEN THEN ; : extract.offset ( -- n ) HERE 4 - @ $FF00FFFF AND $70002D00 = ( is it equal to MOVEQ.L n,D0; MOVE.L D0,-(A6) ) IF HERE 8 - W@ $2D3C = NOT IF ( the constant is not ambiguous ) HERE 4 - W@ $00FF AND -4 ALLOT ELSE CR ." Can't distinguish compiled constant at " HERE 6 - . CR ." Both MOVE.L and MOVEQ.L operands!" ABORT THEN ELSE ( then check for MOVE.L #n,D0; MOVE.L D0,-(a6) ) HERE 8 - W@ $203C = HERE 2- W@ $2D00 = AND IF HERE 6 - @ -8 ALLOT ELSE ( check for MOVE.L #n,-(A6) ) HERE 6 - W@ $2D3C = IF HERE 4 - @ -6 ALLOT ELSE CR 7 EMIT ." Could not find compiled constant offset." ABORT THEN THEN THEN ; GLOBAL : .OF. ( this word attempts to create a record offset address, either on the stack, or by compiling the code for one.) { | >IN.count -- } >IN @ -> >IN.count ( save it in case we have to back up ) 32 WORD ( -- word.addr ) DUP C@ 0= IF ( - addr ) DROP CR ." A record word must follow .OF." ABORT ELSE FIND ( addr -- lfa flag ) 0= ABORT" The word following .OF. could not be found." ( -- lfa ) STATE @ 0= IF ( we are not in a compiling state ) DEPTH ?DUP 0= ABORT" .OF. needs an offset constant on the stack!" LINK>BODY EXECUTE ( -- n depth [addr] ) DEPTH ?DUP 0= ABORT" .OF. needs an address and offset on the stack." ( -- n depth addr depth ) ROT - 1 = NOT ABORT" The word following .OF. must push an address on the stack." + ELSE ( -- lfa ) ( we are compiling, so compiling the following word should compile the code for that word into the dictionary.) DUP ['] ['] BODY>LINK = ( -- lfa flag ) 1 PICK ['] ^ BODY>LINK = ( -- lfa flag flag ) OR IF ( -- lfa ) extract.offset SWAP ( -- n lfa ) LINK>BODY EXECUTE insert.offset ELSE ( -- lfa ) ( the word is hopefully some sort of variable and has to be compiled. ) extract.offset SWAP DUP is.MACH? IF ( -- n lfa ) macro.compile ( n lfa -- n ) ( now install the final offset ) insert.offset ELSE ( -- n lfa ) DUP is.name.field.word? IF ( -- n lfa ) macro.compile insert.offset ELSE DROP ( since we are compiling a JSR, just compile the offset number, then compile the JSR ) [COMPILE] LITERAL >IN.count >IN ! [COMPILE] [COMPILE] THEN THEN THEN ( now check for a following fetch or store, and if so, modify the MOVE.L A0,-(A6) to a MOVE.L (A0),-(A6) ) HERE 2- W@ $2D08 = IF >IN @ -> >IN.count 32 WORD FIND ( -- lfa flag ) 0= IF ( could not find the word, back out ) DROP >IN.count >IN ! ELSE ( -- lfa ) CASE ['] @ BODY>LINK OF $2D10 HERE 2- W! ENDOF ['] W@ BODY>LINK OF $4280 HERE 2- W! \ CLR.L D0 $3010 W, \ MOVE.W (A0),D0 $2D00 W, \ MOVE.L D0,-(A6) ENDOF ['] C@ BODY>LINK OF $4280 HERE 2- W! \ CLR.L D0 $1010 W, \ MOVE.B (A0),D0 $2D00 W, \ MOVE.L D0,-(A6) ENDOF ['] ! BODY>LINK OF $209E HERE 2- W! \ MOVE.L (A6)+,(A0) ENDOF ['] W! BODY>LINK OF $30AE HERE 2- W! \ MOVE.W 2(A6),(A0) 2 W, $588E W, \ ADDQ.L #4,A6 ENDOF ['] C! BODY>LINK OF $10AE HERE 2- W! \ MOVE.B 3(A6),(A0) 3 W, $588E W, \ ADDQ.L #4,A6 ENDOF ( the next word is not a fetch, back out ) >IN.count >IN ! ENDCASE THEN THEN THEN THEN ; IMMEDIATE GLOBAL : is.white.space? C@ DUP $20 = SWAP $09 = OR ; GLOBAL : GET.NEXT.WORD { | start.addr addr word.addr -- addr } ( imitate WORD but remove white space ) WORD -> word.addr word.addr 1+ -> addr BEGIN addr is.white.space? WHILE 1 +> addr REPEAT addr -> start.addr 1 +> addr BEGIN addr is.white.space? NOT WHILE 1 +> addr REPEAT addr start.addr - word.addr C! start.addr word.addr 1+ = NOT IF ( move the string ) start.addr word.addr 1+ word.addr C@ CMOVE THEN word.addr ; -2 ALLOT : ;RECORD ( this word is used to end the record definitions ) ; GLOBAL : SizeOf( ( word to return the size of a defined record ) ASCII ) get.next.word FIND 0= IF CR ." Could not find the record definition " COUNT TYPE CR ABORT ELSE ( -- lfa ) LINK>BODY 4+ @ ( get the size stored at offset 4 ) THEN ; : RECORD.OFFSET ( offset - new.offset ) ( This word is the defining word for record constants created by :RECORD. This word is not typically used directly.) DUP CONSTANT 32 WORD ( -- offset @string ) DUP C@ 0= ABORT" A constant or constant definition must follow a record item." FIND ( -- offset addr flag ) 0= IF ( -- offset addr ) DUP NUMBER? ( -- offset addr n f ) 0= ABORT" Could not find type word or size constant for record definition constant." SWAP DROP ELSE ( -- offset addr ) DEPTH SWAP LINK>BODY EXECUTE ( -- offset depth [n] ) DEPTH ROT - 1 = NOT ABORT" The record item type must resolve to a constant." THEN ( -- offset n ) + ; : VarRec ; : *VarRec ; : CodeRec ; : *CodeRec ; GLOBAL : allocate.record ( The defining word for a record variable. When a record is defined, as in: "… RName rec.var1 type …", this word is executed by the Record Definition word RName. ) MOVE.L (A7)+,-(A6) ( get the pfa for the record size ) ( -- pfa ) @ ( -- size ) >IN @ ( -- size >IN.count ) 32 WORD DROP ( skip over the record variable name ) 32 WORD FIND ( -- size >IN.count addr flag ) ROT >IN ! 0= NOT IF ( -- size lfa ) LINK>BODY CASE ['] VarRec ( allocate a variable record ) OF ( -- size ) VARIABLE 4 - VALLOT ENDOF ['] *VarRec ( allocate a VARIABLE space record pointer ) OF DROP HERE ( -- here ) VARIABLE $2050 SWAP 4 + W! \ MOVEA.L (A0),A0 $41E8 W, \ LEA d(A0),A0 0 W, $2D08 W, \ MOVE.L A0,-(A6) $4E75 W, ENDOF ['] CodeRec ( allocate a code record ) OF ( -- size ) ( use CREATE to create a name field word, then modify it ) ( -- size ) CREATE -4 ALLOT HERE ( -- size here ) 1 NP @ 4 - W! \ set the segment field for a Name field word $2D3C NP @ 2- W! \ MOVE.L #here,-(A6) NP @ ! \ store HERE $4E75 NP @ 4 + W! \ RTS $1234 NP @ 6 + W! \ make this exactly like a HEADER definition 8 NP +! \ allocate the name space ALLOT ENDOF ['] *CodeRec ( allocate a code space record pointer ) OF ( -- size ) ( use CREATE to create a name field word, then modify it ) DROP CREATE HERE 4 - ( - addr ) 1 NP @ 4 - W! \ make it a name space word $2D3C NP @ 2- W! \ MOVE.L #here,-(A6) NP @ ! \ store the starting address $4E75 NP @ 4 + W! \ RTS $1234 NP @ 6 + W! \ add constant to make it like a standard HEADER $4321 NP @ 8 + W! \ add a constant for an indirect record pointer 10 NP +! \ allocate the name space ENDOF ENDCASE 32 WORD DROP \ skip over the type word cuz we already decoded it ELSE CR ." A type definition must follow a typed variable allocation." CR ABORT THEN ; GLOBAL : :RECORD ( this word starts the record definitions process ) STATE @ 0= NOT IF CR ." :RECORD can only be used outside of a colon definition." ABORT ELSE CREATE -4 ALLOT ( overwrite the default code the CREATE puts in ) COMPILE allocate.record ( set the defining word for the record ) HERE ( get the address for the record size ) 4 ALLOT ( allocate space for the record size ) ( -- addr ) 0 ( starting record offset ) BEGIN >IN @ ( save the current spot in the TIB ) 32 WORD DUP ( -- addr offset count addr addr ) FIND ( is the string a valid definition? ) ( There are only three valid words - the two comment words and ;RECORD ) ( -- addr offset count addr lfa flag ) IF 1 PICK C@ 1 = IF ( -- addr offset count addr lfa ) ( if it is a comment string, execute the operator ) 1 PICK 1+ C@ DUP ASCII ( = SWAP ASCII \ = OR IF LINK>BODY EXECUTE DROP DROP 0 ELSE CR 1 PICK COUNT TYPE ." is bad record definition syntax." CR ABORT THEN ELSE ( -- addr offset count addr lfa ) LINK>BODY ['] ;RECORD = IF DROP DROP 1 ELSE CR ." Must end record definition with ;RECORD." CR ABORT THEN THEN ELSE ( -- addr offset count addr lfa ) DROP DROP >IN ! RECORD.OFFSET 0 THEN UNTIL ( -- addr offset ) SWAP ! THEN ; ' insert.offset BODY>LINK 4+ DUP C@ $20 OR SWAP C! ' extract.offset BODY>LINK 4+ DUP C@ $20 OR SWAP C! ' RECORD.OFFSET BODY>LINK 4+ DUP C@ $20 OR SWAP C! ' allocate.record BODY>LINK 4+ DUP C@ $20 OR SWAP C! ONLY ASSEMBLER ALSO DEVELOPMENT ALSO FORTH ALSO MAC DEFINITIONS ( === Compiler support words. === ) ( The Little Guy:John's Stuff ) ( IRIDIUM.SYS:IRIDIUM:SYSTEMS:SYS_TEAM:Network Ops Plan ) #ifndef _MacTypes_ INCLUDE" IRIDIUM.SYS:IRIDIUM:SYSTEMS:SYS_TEAM:Network Ops Plan:Includes:MacTypes.4th.inc" #endif INCLUDE" IRIDIUM.SYS:IRIDIUM:SYSTEMS:SYS_TEAM:Network Ops Plan:Includes:Modules.4th" #ifndef _FSEQU_ INCLUDE" IRIDIUM.SYS:IRIDIUM:SYSTEMS:SYS_TEAM:Network Ops Plan:Includes:FSEqu.Txt" #endif #ifndef _SYSEQU_ INCLUDE" IRIDIUM.SYS:IRIDIUM:SYSTEMS:SYS_TEAM:Network Ops Plan:Includes:SysEqu.Txt" #endif push.VOCAB.state ONLY DEVELOPMENT ALSO FORTH ALSO ASSEMBLER ALSO MAC DEFINITIONS DECIMAL 1536 Insert.MODULE _SYSENV_ $9F CONSTANT UnknownTrap.# $9F CONSTANT Unimplemented.# $90 CONSTANT SysEnvirons.# $1AD CONSTANT Gestalt.# $A89F CONSTANT UnknownTrap.opcode $A89F CONSTANT Unimplemented.opcode $A090 CONSTANT SysEnvirons.opcode $A1AD CONSTANT Gestalt.opcode ( ===== System Globals ===== ) $12F CONSTANT CPUFlag ( byte ) $21E CONSTANT KbdType ( byte ) $A58 CONSTANT SysMap ( global that contains System Map reference # ) $B22 CONSTANT HWCfgFlags $B22 CONSTANT SCSIFlags ( ===== System Global Constants ===== ) 15 CONSTANT SCSI.port.present.bit $8000 CONSTANT SCSI.port.present.mask 14 CONSTANT New.Clock.Chip.Present.bit $4000 CONSTANT New.Clock.Chip.Present.mask 13 CONSTANT Extra.PRAM.Valid.bit $2000 CONSTANT Extra.PRAM.Valid.mask ( at boottime ) 4 CONSTANT has.FPU.bit ( in HwCfgFlags ) $0010 CONSTANT has.FPU.mask 0 CONSTANT OSTrap 1 CONSTANT ToolTrap ( SysEnvirons returned keyboard constants ) 0 CONSTANT envUnknownKbd ( Macintosh Plus keyboard with keypad ) 1 CONSTANT envMacKbd ( Macintosh keyboard ) 2 CONSTANT envMacAndPad ( Macintosh keyboard and keypad ) 3 CONSTANT envMacPlusKbd ( Macintosh Plus keyboard ) 4 CONSTANT envAExtendKbd ( Apple extended Kbd ) 5 CONSTANT envStandADBKbd ( standard Apple Desktop Bus keyboard ) 6 CONSTANT envPortADBKbd ( Portable Keyboard ) 7 CONSTANT envPortISOADBKbd ( Portable Keyboard (ISO) ) 8 CONSTANT envStdISOADBKbd ( Apple Standard Keyboard (ISO) ) 9 CONSTANT envExtISOADBKbd ( Apple Extended Keyboard (ISO) ) 10 CONSTANT envADBKbdII ( Apple Keyboard II ) 11 CONSTANT envADBISOKbdII ( Apple Keyboard II (ISO) ) 11 CONSTANT no.of.kbds _SYSENV_ restore.name.space ( ===== SysEnviron record constants ===== ) :RECORD SysEnvRec environsVersion short machineType short systemVersion short processor short hasFPU char hasColorQD char keyBoardType short atDrvrVersNum short sysVRefNum short ;RECORD CODE NGetTrapAddress.Tool ( trap# -- addr ) MOVE.W 2(A6),D0 EXG.L D4,A7 _GetTrapAddress ,NEWTOOL EXG.L D4,A7 MOVE.L A0,(A6) RTS END-CODE MACH CODE NGetTrapAddress.OS ( trap# -- addr ) MOVE.W 2(A6),D0 EXG.L D4,A7 _GetTrapAddress ,IMMED ( same as ,NEWOS ) EXG.L D4,A7 MOVE.L A0,(A6) RTS END-CODE MACH : NumToolboxTraps ( -- number ) $6E NGetTrapAddress.Tool ( _InitGraf ) $AA6E NGetTrapAddress.Tool = IF $200 ELSE $400 THEN ; GLOBAL : GetTrapType ( trap -- traptype ) $0800 AND 0> IF ToolTrap ELSE OSTrap THEN ; GLOBAL : TrapAvailable? { trap.# | trapType -- flag } trap.# GetTrapType -> trapType trapType ToolTrap = IF trap.# $07FF AND -> trap.# trap.# NumToolboxTraps < NOT IF UnknownTrap.# -> trap.# THEN THEN trap.# trapType ToolTrap = IF NGetTrapAddress.Tool ELSE NGetTrapAddress.OS THEN UnknownTrap.# NGetTrapAddress.Tool = NOT ; GLOBAL : Gestalt.Exist? ( -- flag ) Gestalt.opcode TrapAvailable? ; GLOBAL : SysEnvirons.Exist? ( -- flag ) SysEnvirons.opcode TrapAvailable? ; ( here is included code to execute when SysEnvirons is not available ) : setmachineType ( -- n ) ROMBase @ 9 + C@ $FF = NOT IF ( it is not a MAC XL ) ROM85 W@ $8000 AND 0= IF ( it is a 512KE or better - if it has the new clock chip it is a Mac Plus ) HWCfgFlags W@ New.Clock.Chip.Present.mask AND 0= IF ( new clock chip is not present - a 512KE ) 1 ELSE ( at least a Plus ) ( test for Mac SE or Mac II ) ROMBase @ 8 + W@ CASE $75 OF 2 ENDOF ( a MAC Plus ) $76 OF 3 ENDOF ( a MAC SE ) $78 OF 4 ENDOF ( a Mac II ) ( else it is an unknown Mac ) 0 SWAP ENDCASE THEN ELSE ( it's a 128 or 512K Mac) -1 THEN ELSE ( it is a Lisa ) -2 THEN ; : set.processor.type ( -- n ) CPUFlag C@ 3 > IF 0 ELSE CPUFlag C@ 1+ THEN ; : set.FPU.exist ( -- n ) HWCfgFlags W@ has.FPU.mask AND 0= IF 0 ELSE 1 THEN ; CODE set.Color.QD.exist ( -- n ) MOVE.W ROM85,-(A6) CMPI.W #$3FFF,(A6) BHI.S @noCQD MOVE.W #1,(A6) BRA.S @addpad @noCQD CLR.W (A6) @addpad CLR.W -(A6) RTS END-CODE ( Comparing keyboard type in KbdType, and the value returned by SysEnvirons KbdType $03 $13 $0B $02 $01 $06 $07 $04 $05 $08 $09 | | | | | | | | | | | SysEnvirons $01 $02 $03 $04 $05 $06 $07 $08 $09 $0A $0B | | | | | | | | | | | | | | | | | | | | | Apple Keyboard II (ISO) | | | | | | | | | Apple Keyboard II | | | | | | | | Apple Extended Keyboard (ISO) | | | | | | | Apple Standard Keyboard (ISO) | | | | | | Portable Keyboard (ISO) | | | | | Portable Keyboard | | | | standard Apple Desktop Bus keyboard | | | Apple extended Kbd | | Macintosh Plus keyboard | Macintosh keyboard and keypad Macintosh keyboard ) CODE get.keyboard.type ( -- type ) BRA.S @dokb ( Compile a CONSTANT array of keyboard types ) DC.B $00 DC.B $03 DC.B $13 DC.B $0B DC.B $02 DC.B $01 DC.B $06 DC.B $07 DC.B $04 DC.B $05 DC.B $08 DC.B $09 @dokb LEA -2(PC),A0 MOVE.B KbdType,D0 \ get current keyboard type MOVE.W #no.of.kbds,D1 SUBQ.W #1,D1 @next.type CMP.B -(A0),D0 DBEQ D1,@next.type ADDQ.W #1,D1 EXT.L D1 MOVE.L D1,-(A6) RTS END-CODE ( Now we need to get the AppleTalk version number ) : get.AppleTalk.Version ( -- version ) ( first check SPConfig and PortBUse ) SPConfig C@ $0F AND 1 = ( port is configured for ATalk, check for PortBUse ) $291 ( PortBUse ) C@ 0> AND $291 ( PortBUse ) C@ $0F AND 1 = AND IF ( AppleTalk .MPP is open, so get the version number ) UTableBase @ 36 + @ ( addr of .MPP DCE ) 7 + C@ ELSE ( AppleTalk not open ) 0 THEN ; GLOBAL : HGetVInfo ( This routine used the variable array "file.iopb" and "vol.name" and calls the ROM routine HGetVInfo, using a passed-in volume ID.) { volume.ID @file.ioPB @vol.name -- resultcode } 0 ioCompletion .OF. @file.ioPB ! @vol.name ioFileName .OF. @file.ioPB ! volume.ID ioVRefNum .OF. @file.iopb W! 0 ioVolIndex .OF. @file.ioPB W! @file.iopb CALL HGetVInfo ( -- result ) ; GLOBAL : get.THE.blessed.WD ( This routine gets the Working directory number of the blessed folder that contains the current open system file - use this routine when SysEnvirons is not available.) ( -- WDRefNum ) { | [ 118 LALLOT ] @file.ioPB -- } ( do it the hard and scary way ) 0 ioCompletion .OF. ^ @file.iopb ! 0 ioVRefNum .OF. ^ @file.iopb W! SysMap W@ ioRefNum .OF. ^ @file.iopb W! 0 ioFCBIndex .OF. ^ @file.iopb ! ^ @file.iopb CALL GetFCBInfo ( -- result.code ) 0= IF ioVRefNum .OF. ^ @file.iopb W@ DUP 0= IF ( dir.ID -- ) ( either the volume is MFS or there is no blessed folder on this volume ) ioVSigWord .OF. ^ @file.iopb W@ TSigWord = IF ( it's an HFS volume with no blessed folder, so it's not the boot volume. Use the global BootDrive to find the boot drive and get it's blessed folder ID.) DROP BootDrive W@ ^ @file.ioPB 0 ( -- vol.ID @file.ioPB @vol.name ) HGetVInfo 0= IF ioVFndrInfo .OF. ^ @file.iopb @ ELSE ( a fatal error occurred ) 0 THEN THEN THEN ( -- dir.ID ) ELSE ( a fatal error occurred ) 0 THEN ( -- WDRefNum ) ; CODE fake.SysEnv ( SysEnvRec version -- SysEnvRec result ) MOVE.L A3,-(A7) \ save A3 MOVE.L 4(A6),A3 \ get the SysEnvRec pointer MOVEQ.L #1,D0 \ set the Version number MOVE.W D0,(A3)+ setmachineType \ get the Machine type MOVE.L (A6)+,D0 MOVE.W D0,(A3)+ MOVEQ.L #0,D0 \ set the system file version MOVE.W D0,(A3)+ set.processor.type \ get the CPU type MOVE.L (A6)+,D0 MOVE.W D0,(A3)+ set.FPU.exist \ is there a floating point processor MOVE.L (A6)+,D0 MOVE.B D0,(A3)+ set.Color.QD.exist \ is color QuickDraw available MOVE.L (A6)+,D0 MOVE.B D0,(A3)+ get.keyboard.type \ which keyboard are we using MOVE.L (A6)+,D0 MOVE.W D0,(A3)+ get.AppleTalk.Version MOVE.L (A6)+,D0 MOVE.W D0,(A3)+ get.THE.blessed.WD MOVE.L (A6)+,D0 MOVE.W D0,(A3)+ MOVE.L (A7)+,A3 MOVE.L #-5500,(A6) RTS END-CODE GLOBAL CODE SysEnvirons ( SysEnvRec version -- SysEnvRec result ) SysEnvirons.Exist? TST.L (A6)+ BEQ.S @noSysEnv EXG D4,A7 MOVE.W 2(A6),D0 MOVE.L 4(A6),A0 _SysEnvirons MOVE.L A0,4(A6) EXT.L D0 MOVE.L D0,(A6) EXG D4,A7 BRA.S @this.exit @noSysEnv fake.SysEnv @this.exit RTS END-CODE GLOBAL CODE (CALL).SysEnvirons ( SysEnvRec version -- SysEnvRec result ) SysEnvirons.Exist? TST.L (A6)+ BEQ.S @noSysEnv MOVE.W 2(A6),D0 MOVE.L 4(A6),A0 _SysEnvirons MOVE.L A0,4(A6) EXT.L D0 MOVE.L D0,(A6) BRA.S @this.exit @noSysEnv fake.SysEnv @this.exit RTS END-CODE MACH _SYSENV_ forget.MODULE pop.VOCAB.state ONLY DEVELOPMENT DEFINITIONS ALSO MAC ALSO FORTH ALSO ASSEMBLER ( The following two words are used to restart a suspended task when its Apple Event handler gets called. Since by definition, an Apple Event handler gets called while in the IOTASK and using the TRAP-STACK, it is necesary to do a context switch back into the suspended task. The handler must not PAUSE, since it really is executing inside the environment provided by AEHandleEvent. This allows the handler access to all of its task variables, and task variables of other tasks. The handler must leave the OSErr result on the stack and nothing else. To perform further processing, leave data in UserVector and UserData. Use these two words as follows: : my.AE.handler AEHandler.entry (my.AE.handler) ( the.Apple.Event reply -- OSErr ) AEHandler.exit ; ) CODE AEHandler.entry \ stack frame: \ (A7): return address \ 4(A7): refcon, must be the pointer to task space \ 8(A7): reply \ 12(A7): AppleEvent \ 16(A7): OSErr \ LINK A0,#0 \ setup a stack frame MOVEM.L D0-D7/A1-A4/A6,-(A7) \ save all registers MOVE.L 8(A0),A4 \ setup the Task pointer MOVE.L A7,D4 \ setup the TrapStack pointer MOVE.L 8(A4),A6 \ get the Task A6 stack MOVEM.L (A6)+,D5-D7/A2-A3/A7 \ we are now back in the task MOVE.L A0,-(A6) \ store addr of stack frame MOVE.L 16(A0),-(A6) \ theAppleEvent MOVE.L 12(A6),-(A6) \ reply RTS END-CODE MACH CODE AEHandler.exit \ the first thing is to re-suspend the task MOVE.L (A6)+,D0 \ get the OSErr MOVE.L (A6)+,A0 \ restore the stack frame MOVE.W D0,20(A0) \ store the OSErr result MOVEM.L D5-D7/A2-A3/A7,-(A6) \ save the task state MOVE.L A6,$8(A4) \ save off the A6 stack MOVE.L D4,A7 \ restore the callers stack MOVEM.L (A7)+,D0-D7/A1-A4/A6 \ restore all registers UNLK A0 \ unlink the stack frame RTD #12 \ and return to the system RTS \ need this for the MACH copier END-CODE MACH CODE AE: JSR CREATE \ create the handler JSR RECURSIVE \ hide the handler name SUBQ.L #4,$-1EC(A5) \ recover code space used by CREATE COMPILE AEHandler.entry \ compile the glue code MOVE.L D5,(A3)+ \ push MACH2 internal constant MOVE.L D6,D5 \ onto return stack MOVE.L #$99887766,D6 JMP ] \ start normal compilation END-CODE IMMEDIATE CODE ;AE COMPILE AEHandler.exit JMP ; \ finish up this definition END-CODE IMMEDIATE : XDEF: ( - branch marker ) CREATE -4 ALLOT $4EFA W, ( JMP ) 0 W, ( entry point to be filled later ) 0 , ( length of routine to be filled later ) HERE 6 - 76543 ( marker ) ; : ;XDEF { branch marker entry | - } marker 76543 <> ABORT" XDEF Mismatch!" entry branch - branch W! HERE branch - 2+ branch 2+ ! ; CODE INIT.prelude MOVE.L A3,-(A7) LINK A6,#-2048 \ allocate a 2K FORTH stack [ HERE 2- ] \ save addr of stack size value MOVE.L A7,A3 \ setup local loop return stack MOVEM.L A0-A1,-(A7) \ save these registers MOVE.L A0,-(A6) \ pass pointer to INIT RTS END-CODE MACH HERE 2- - ( get positive offset from end of routine to stack size ) : Set.INIT.stack= 32 WORD NUMBER? IF NEGATE HERE LITERAL + W! ELSE CR ." A stack size must follow Set.INIT.stack= …" ABORT THEN ; IMMEDIATE CODE INIT.epilog MOVEM.L (A7)+,A0-A1 \ restore stuff UNLK A6 MOVE.L (A7)+,A3 RTS END-CODE MACH CODE DA.prelude LINK A6,#-2048 \ allocate a 2K FORTH stack [ HERE 2- ] \ push addr of size of parameter stack MOVEM.L A0-A1,-(A7) \ save these registers MOVE.L A6,A3 \ setup local loop return stack SUBA.W #1792,A3 \ leave space for FP stack [ HERE 2- ] \ push addr of offset to return stack MOVE.L A3,D7 \ setup pointer to FP stack MOVE.L A0,-(A6) \ pass parameter block MOVE.L A1,-(A6) \ pass DCE RTS END-CODE MACH HERE 2- - SWAP HERE 2- - : Set.DA.stack= 32 WORD NUMBER? IF DUP NEGATE HERE LITERAL + W! 200 - HERE LITERAL + W! ELSE CR ." A stack size value must follow the word Set.DA.stack= …" ABORT THEN ; IMMEDIATE CODE DA.epilog MOVE.L (A6)+,D0 \ pass return code MOVEM.L (A7)+,A0-A1 \ restore stuff UNLK A6 RTS END-CODE MACH _FSEQU_ forget.MODULE _SYSEQU_ forget.MODULE CR .( Use NEW-SEGMENT to write out the new Segment 18 code image ) CR .( and the new dictionary to a file.)